perm filename TICTA2.LSP[206,JMC] blob sn#073067 filedate 1973-11-18 generic text, type T, neo UTF8
00100	
00200	
00300	(DEFPROP TICTACFNS
00400	 (TRY2 COMMENCE
00500	       NEWGAME
00600	       TER
00700	       IMVAL
00800	       SUCCESSORS
00900	       REVERT
01000	       UPDATE
01100	       PTS
01200	       LINES
01300	       SORT
01400	       SORTA
01500	       SORTB
01600	       SORTC
01700	       WIN
01800	       ANSWER
01900	       DOUBLETH
02000		TWOLIS
02100	       THREAT)
02200	VALUE)
02300	
02400	(DEFPROP COMMENCE
02500	 (LAMBDA NIL
02600	  (PROG	NIL
02700		(ARRAY LINES T 12)
02800		(ARRAY XCOUNT 44 11)
02900		(ARRAY OCOUNT 44 11)
03000		(STORE (LINES 1) (QUOTE (1 4 7)))
03100		(STORE (LINES 2) (QUOTE (1 5)))
03200		(STORE (LINES 3) (QUOTE (1 6 10)))
03300		(STORE (LINES 4) (QUOTE (2 4)))
03400		(STORE (LINES 5) (QUOTE (2 5 7 10)))
03500		(STORE (LINES 6) (QUOTE (2 6)))
03600		(STORE (LINES 7) (QUOTE (3 4 10)))
03700		(STORE (LINES 10) (QUOTE (3 5)))
03800		(STORE (LINES 11) (QUOTE (3 6 7)))))
03900	EXPR)
04000	
04100	(DEFPROP NEWGAME
04200	 (LAMBDA NIL
04300	  (PROG	(N)
04400		(SETQ N 0)
04500	   L	(SETQ N (ADD1 N))
04600		(STORE (XCOUNT N) 0)
04700		(STORE (OCOUNT N) 0)
04800		(COND ((LESSP N 10) (GO L)))
04900		(SETQ P1 NIL)
05000		(SETQ XS NIL)
05100		(SETQ OS NIL)
05200		(SETQ BS (QUOTE (1 2 3 4 5 6 7 10 11)))
05300		(SETQ W NIL)
05400		(SETQ LEVEL 0)
05500		(SETQ COUNT 0)
05600		(RETURN (QUOTE (NEW GAME)))))
05700	EXPR)
05800	
05900	(DEFPROP TER
06000	 (LAMBDA(P ALPHA BETA)
06100	  (AND (NOT (NULL P))
06200	       (OR (EQUAL LEVEL 11)
06300		   (LESSP (DIFFERENCE 11 LEVEL) (CAR ALPHA))
06400		   (GREATERP (PLUS -11 LEVEL) (CAR BETA))
06500		   (PROG (N)
06600			 (SETQ N 0)
06700		    L2	 (SETQ N (ADD1 N))
06800			 (COND ((EQUAL 3 (COND (W (XCOUNT N)) (T (OCOUNT N)))) (RETURN T)))
06900			 (COND ((LESSP N 10) (GO L2)))
07000			 (RETURN NIL)))))
07100	EXPR)
07200	
07300	(DEFPROP IMVAL
07400	 (LAMBDA(P ALPHA BETA)
07500	  (COND	(W
07600		 (PROG (N)
07700		       (SETQ N 0)
07800		  L3   (SETQ N (ADD1 N))
07900		       (COND ((EQUAL 3 (XCOUNT N)) (RETURN (DIFFERENCE 12 LEVEL))))
08000		       (COND ((LESSP N 10) (GO L3)) (T (RETURN 0)))))
08100		(T
08200		 (PROG (N)
08300		       (SETQ N 0)
08400		  L4   (SETQ N (ADD1 N))
08500		       (COND ((EQUAL 3 (OCOUNT N)) (RETURN (PLUS -12 LEVEL))))
08600		       (COND ((LESSP N 10) (GO L4)) (T (RETURN 0)))))))
08700	EXPR)
08800	
08900	(DEFPROP SUCCESSORS
09000	 (LAMBDA (P ALPHA BETA) (SORT (MAPCAR (FUNCTION (LAMBDA (X) (CONS X P))) BS)))
09100	EXPR)
09200	
09300	(DEFPROP REVERT
09400	 (LAMBDA NIL
09500	  (PROG	(A)
09600		(SETQ LEVEL (SUB1 LEVEL))
09700		(SETQ BS (CONS (CAR (COND (W XS) (T OS))) BS))
09800		(COND (W (SETQ XS (CDR XS))) (T (SETQ OS (CDR OS))))
09900		(SETQ A (LINES (CAR P1)))
10000	   L5	(COND ((NULL A) (GO L6)))
10100		(COND (W (STORE (XCOUNT (CAR A)) (SUB1 (XCOUNT (CAR A)))))
10200		      (T (STORE (OCOUNT (CAR A)) (SUB1 (OCOUNT (CAR A))))))
10300		(SETQ A (CDR A))
10400		(GO L5)
10500	   L6	(SETQ W (NOT W))
10600		(SETQ P1 (CDR P1))
10700		(RETURN)))
10800	EXPR)
10900	
11000	(DEFPROP UPDATE
11100	 (LAMBDA(M)
11200	  (PROG	(A)
11300		(SETQ LEVEL (ADD1 LEVEL))
11400		(COND (W (SETQ OS (CONS M OS))) (T (SETQ XS (CONS M XS))))
11500		(SETQ BS (DELETE M BS))
11600		(SETQ P1 (CONS M P1))
11700		(SETQ COUNT (ADD1 COUNT))
11800		(SETQ A (LINES M))
11900	   L7	(COND ((NULL A) (GO L8)))
12000		(COND (W (STORE (OCOUNT (CAR A)) (ADD1 (OCOUNT (CAR A)))))
12100		      (T (STORE (XCOUNT (CAR A)) (ADD1 (XCOUNT (CAR A))))))
12200		(SETQ A (CDR A))
12300		(GO L7)
12400	   L8	(SETQ W (NOT W))
12500		(RETURN )))
12600	EXPR)
12700	
12800	(DEFPROP SORT
12900	 (LAMBDA (U) (SORTA U NIL NIL))
13000	EXPR)
13100	
13200	(DEFPROP SORTA
13300	 (LAMBDA(U TH ORD)
13400	  (COND	((NULL U) (APPEND TH ORD))
13500		((WIN (CAR U)) (LIST (CAR U)))
13600		((ANSWER (CAR U)) (SORTB (CDR U) (CAR U)))
13700		((DOUBLETH (CAR U)) (SORTC (CDR U) (CAR U)))
13800		((THREAT (CAR U)) (SORTA (CDR U) (CONS (CAR U) TH) ORD))
13900		(T (SORTA (CDR U) TH (CONS (CAR U) ORD)))))
14000	EXPR)
14100	
14200	(DEFPROP SORTB
14300	 (LAMBDA (U M) (COND ((NULL U) (LIST M)) ((WIN (CAR U)) (LIST (CAR U))) (T (SORTB (CDR U) M))))
14400	EXPR)
14500	
14600	(DEFPROP SORTC
14700	 (LAMBDA(U M)
14800	  (COND	((NULL U) (LIST M))
14900		((WIN (CAR U)) (LIST (CAR U)))
15000		((ANSWER (CAR U)) (SORTB (CDR U) (CAR U)))
15100		(T (SORTC (CDR U) M))))
15200	EXPR)
15300	
15400	(DEFPROP WIN
15500	 (LAMBDA(P)
15600	  (COND	(W (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (OCOUNT X)))) (LINES (CAR P))))
15700		(T (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (XCOUNT X)))) (LINES (CAR P))))))
15800	EXPR)
15900	
16000	(DEFPROP ANSWER
16100	 (LAMBDA(P)
16200	  (COND	(W (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (XCOUNT X)))) (LINES (CAR P))))
16300		(T (ORLIS (FUNCTION (LAMBDA (X) (EQUAL 2 (OCOUNT X)))) (LINES (CAR P))))))
16400	EXPR)
16500	
16600	(DEFPROP DOUBLETH
16700	 (LAMBDA(P)
16800	  (TWOLIS (FUNCTION
16900		   (LAMBDA(X)
17000		    (AND (EQUAL 1 (COND (W (OCOUNT X)) (T (XCOUNT X))))
17100			 (ORLIS (FUNCTION (LAMBDA (W) (MEMBER X (LINES W)))) (DELETE (CAR P) BS)))))
17200		  (LINES (CAR P))))
17300	EXPR)
17400	
17500	(DEFPROP THREAT
17600	 (LAMBDA(P)
17700	  (ORLIS (FUNCTION
17800		  (LAMBDA(X)
17900		   (AND	(EQUAL 1 (COND (W (OCOUNT X)) (T (XCOUNT X))))
18000			(ORLIS (FUNCTION (LAMBDA (W) (MEMBER X (LINES W)))) (DELETE (CAR P) BS)))))
18100		 (LINES (CAR P))))
18200	EXPR)
18300	
18400	(DE TWOLIS (PRED U) (AND (NOT (NULL U))
18500		(OR (AND (PRED (CAR U)) (ORLIS PRED (CDR U)))
18600		    (TWOLIS PRED (CDR U)))))